*      The following Fortran 90 code listing fragments are from 
*      Thomas M. Lahey's article entitled "Fortran 90 is Coming!"

*** LISTING 1
       REAL, DIMENSION(:,:), ALLOCATABLE :: temps, pressures
       ...
       n = 16384            ! Try for arrays of 24*8192 elements
10     n = n/2              ! n too big, halve it
       ALLOCATE ( temps(24, n), STAT=notice )
       IF ( notice .NE. 0 ) GO TO 10    ! temps not allocated
       ALLOCATE ( pressures(24, n), STAT=notice )
       IF ( notice .NE. 0 ) THEN
           DEALLOCATE ( temps );  GO TO 10
       ENDIF

!  pressures and temps have been allocated 24 by n elements.
       IF ( n << 1024 ) THEN
           PRINT '(" Only able to allocate"I4," elements")', n
           STOP "Quitting"
       ENDIF
       ...


*** LISTING 2

!  pntr1 & pntr2 associate only with two-dimensional REAL arrays
       COMMON /pointers/ pntr1, pntr2
       REAL, POINTER, DIMENSION(:,:) ::  pntr1,  pntr2

!  array1 & array2 are descriptors that "know" they are unallocated
!  TARGET is required since they will be associated with a pointer
       REAL, TARGET, DIMENSION(:,:)  ::  array1, array2
       ...
       ALLOCATE ( array1(50,50), array2(70,90) )
       pntr1 =>> array1;  pntr2 =>> array2  !POINTER ASSIGNMENTs
       CALL s        ! if s declares COMMON /pointers/, then it can
                     ! access array1 and array2
       ...


***LISTING 3

       FUNCTION elements(string)            ! Count words
       IMPLICIT NONE;         INTEGER i
       CHARACTER*(*) string;  LOGICAL separator
       TYPE inventory
           INTEGER nwords, nletters, npunct, nblanks, nelse
       END TYPE inventory
       TYPE (inventory) elements

!  Initialize structure, INTRINSIC TRIM removes trailing blanks
       elements%nwords = 0;  elements%nletters = 0
       elements%npunct = 0;  elements%nelse = 0
       elements%nblanks = LEN(string) - LEN( TRIM(string) )

       IF ( string == '' ) RETURN               ! All blanks
       separator = .TRUE.                       ! To count words

block1:  DO  i = 1, LEN( TRIM(string) )  ! No trailing ' '
               SELECT CASE ( string(i:i) )
                  CASE ( ' ' )             ! Blank
                      elements%nblanks = elements%nblanks +1
                      separator = .TRUE.
                  CASE (a:z, A:Z)          ! Letters
                      elements%nletters = elements%nletters +1
                      IF ( separator ) THEN    ! New word?
                          nwords = nwords +1  ! Yes
                          separator = .FALSE.
                      ENDIF
                  CASE ( '.', ',', ';' )        ! Punctuation
                      separator = .TRUE.
                      elements%npunct = elements%npunct +1
                  CASE DEFAULT                 ! All others
                      elements%nelse = elements%nelse +1
               END SELECT
           END DO  block1
       END


***LISTING 4

       MODULE ISO_string

!  Derived-type dynamic-length CHAR item: POINTER to rank-one array
       TYPE string        ! User defines DERIVED-TYPE STRINGs
          PRIVATE         ! Component "chars" unavailable to user
          CHARACTER, DIMENSION(:), POINTER  ::  chars
       END TYPE string

       INTERFACE ASSIGNMENT(=)
          MODULE PROCEDURE    ! MODULE SUBROUTINEs defined below
      &   s_eqs_s,            ! CALLed if string = string parsed
      &   s_eqs_c,            ! CALLed if string = char parsed
      &   c_eqs_s             ! CALLed if char = string parsed
       END INTERFACE

       INTERFACE OPERATOR(//)
          MODULE PROCEDURE    ! MODULE FUNCTIONs defined later
      &   s_concat_s,         ! Invoked if string // string parsed
      &   s_concat_c,         ! Invoked if string // char parsed
      &   c_concat_s          ! Invoked if char // string parsed
       END INTERFACE

!  Note: The ISO MODULE defines relational operators
!  Note: The ISO MODULE defines its INTRINSIC FUNCTIONs LEN, INDEX
!  Note: The ISO MODULE defines type conversions for internal 
use
!      ...  A lot more code!
       SUBROUTINE s_eqs_s(st, ss)! Compiler CALLs when
                                 ! string = string is parsed
       TYPE (string) INTENT(OUT)  ::  st
       TYPE (string) INTENT(IN)   ::  ss
       IF ( .NOT. ASSOCIATED(ss%chars) ) CALL error
       IF ( ASSOCIATED(st%chars) ) THEN
          IF ( ASSOCIATED(ss%chars, st%chars)   ) RETURN
          NULLIFY (st%chars)
       ENDIF
       st%chars = ss%chars
       END SUBROUTINE s_eqs_s
!      ... A lot more code!
       END MODULE ISO_string

!  Using the string MODULE
       USE string               ! The MODULE
       TYPE (string) s1, s2     ! MODULE has type definition
       ...
       s1 = 'abc def '          ! Trailing blank preserved, 
s_eqs_c
       s2 = 'ghi jkl mno'
       ...
       s1 = s2 // s1           ! // is overloaded operator, 
compiler
                               ! invokes function s_cat_s(s2,s1) 
then
                               ! CALL s_eqs_s(s1,string_temp)
       PRINT *, s1             ! Compiler prints structure components
       END


***LISTING 5

      SUBROUTINE sub
      CALL s
      PRINT *, i, j            ! i & j are known to internals

      CONTAINS                 ! Required, separates host & internals

      SUBROUTINE s
      i = nj(5);    END        ! i not declared locally, must be host

      FUNCTION nj(k)
      j = k+5;      END        ! j not declared locally, must be host

      END SUBROUTINE sub


***LISTING 6

       NAMELIST /study_params/ temp, pres, volume
       REAL, PARAMETER  ::  n = 6.02252E23,  R = 0.0823
10     PRINT *, 'To terminate, enter both values as 0'
       PRINT *, 'If not changing both params end with /, no ,'
       PRINT *, 'Input: &study_params temp=value, pres=value/'
       IF ( temp .EQ. 0  .AND. pres .EQ. 0 ) STOP 'All done'
       READ  (*, NML=study_params)
       volume = n*R*temp/pres        ! Remember:  PV = nRT
       WRITE (*, NML=study_params)   ! Outputs: temp, pres, & volume
       GO TO 10
       END 

